home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / tcltk / tk8.5 / menu.tcl < prev    next >
Encoding:
Text File  |  2009-11-17  |  35.8 KB  |  1,317 lines
  1. # menu.tcl --
  2. #
  3. # This file defines the default bindings for Tk menus and menubuttons.
  4. # It also implements keyboard traversal of menus and implements a few
  5. # other utility procedures related to menus.
  6. #
  7. # RCS: @(#) $Id: menu.tcl,v 1.26.2.5 2009/04/10 16:08:45 das Exp $
  8. #
  9. # Copyright (c) 1992-1994 The Regents of the University of California.
  10. # Copyright (c) 1994-1997 Sun Microsystems, Inc.
  11. # Copyright (c) 1998-1999 by Scriptics Corporation.
  12. # Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
  13. #
  14. # See the file "license.terms" for information on usage and redistribution
  15. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  16. #
  17.  
  18. #-------------------------------------------------------------------------
  19. # Elements of tk::Priv that are used in this file:
  20. #
  21. # cursor -        Saves the -cursor option for the posted menubutton.
  22. # focus -        Saves the focus during a menu selection operation.
  23. #            Focus gets restored here when the menu is unposted.
  24. # grabGlobal -        Used in conjunction with tk::Priv(oldGrab):  if
  25. #            tk::Priv(oldGrab) is non-empty, then tk::Priv(grabGlobal)
  26. #            contains either an empty string or "-global" to
  27. #            indicate whether the old grab was a local one or
  28. #            a global one.
  29. # inMenubutton -    The name of the menubutton widget containing
  30. #            the mouse, or an empty string if the mouse is
  31. #            not over any menubutton.
  32. # menuBar -        The name of the menubar that is the root
  33. #            of the cascade hierarchy which is currently
  34. #            posted. This is null when there is no menu currently
  35. #            being pulled down from a menu bar.
  36. # oldGrab -        Window that had the grab before a menu was posted.
  37. #            Used to restore the grab state after the menu
  38. #            is unposted.  Empty string means there was no
  39. #            grab previously set.
  40. # popup -        If a menu has been popped up via tk_popup, this
  41. #            gives the name of the menu.  Otherwise this
  42. #            value is empty.
  43. # postedMb -        Name of the menubutton whose menu is currently
  44. #            posted, or an empty string if nothing is posted
  45. #            A grab is set on this widget.
  46. # relief -        Used to save the original relief of the current
  47. #            menubutton.
  48. # window -        When the mouse is over a menu, this holds the
  49. #            name of the menu;  it's cleared when the mouse
  50. #            leaves the menu.
  51. # tearoff -        Whether the last menu posted was a tearoff or not.
  52. #            This is true always for unix, for tearoffs for Mac
  53. #            and Windows.
  54. # activeMenu -        This is the last active menu for use
  55. #            with the <<MenuSelect>> virtual event.
  56. # activeItem -        This is the last active menu item for
  57. #            use with the <<MenuSelect>> virtual event.
  58. #-------------------------------------------------------------------------
  59.  
  60. #-------------------------------------------------------------------------
  61. # Overall note:
  62. # This file is tricky because there are five different ways that menus
  63. # can be used:
  64. #
  65. # 1. As a pulldown from a menubutton. In this style, the variable 
  66. #    tk::Priv(postedMb) identifies the posted menubutton.
  67. # 2. As a torn-off menu copied from some other menu.  In this style
  68. #    tk::Priv(postedMb) is empty, and menu's type is "tearoff".
  69. # 3. As an option menu, triggered from an option menubutton.  In this
  70. #    style tk::Priv(postedMb) identifies the posted menubutton.
  71. # 4. As a popup menu.  In this style tk::Priv(postedMb) is empty and
  72. #    the top-level menu's type is "normal".
  73. # 5. As a pulldown from a menubar. The variable tk::Priv(menubar) has
  74. #    the owning menubar, and the menu itself is of type "normal".
  75. #
  76. # The various binding procedures use the  state described above to
  77. # distinguish the various cases and take different actions in each
  78. # case.
  79. #-------------------------------------------------------------------------
  80.  
  81. #-------------------------------------------------------------------------
  82. # The code below creates the default class bindings for menus
  83. # and menubuttons.
  84. #-------------------------------------------------------------------------
  85.  
  86. bind Menubutton <FocusIn> {}
  87. bind Menubutton <Enter> {
  88.     tk::MbEnter %W
  89. }
  90. bind Menubutton <Leave> {
  91.     tk::MbLeave %W
  92. }
  93. bind Menubutton <1> {
  94.     if {$tk::Priv(inMenubutton) ne ""} {
  95.     tk::MbPost $tk::Priv(inMenubutton) %X %Y
  96.     }
  97. }
  98. bind Menubutton <Motion> {
  99.     tk::MbMotion %W up %X %Y
  100. }
  101. bind Menubutton <B1-Motion> {
  102.     tk::MbMotion %W down %X %Y
  103. }
  104. bind Menubutton <ButtonRelease-1> {
  105.     tk::MbButtonUp %W
  106. }
  107. bind Menubutton <space> {
  108.     tk::MbPost %W
  109.     tk::MenuFirstEntry [%W cget -menu]
  110. }
  111.  
  112. # Must set focus when mouse enters a menu, in order to allow
  113. # mixed-mode processing using both the mouse and the keyboard.
  114. # Don't set the focus if the event comes from a grab release,
  115. # though:  such an event can happen after as part of unposting
  116. # a cascaded chain of menus, after the focus has already been
  117. # restored to wherever it was before menu selection started.
  118.  
  119. bind Menu <FocusIn> {}
  120.  
  121. bind Menu <Enter> {
  122.     set tk::Priv(window) %W
  123.     if {[%W cget -type] eq "tearoff"} {
  124.     if {"%m" ne "NotifyUngrab"} {
  125.         if {[tk windowingsystem] eq "x11"} {
  126.         tk_menuSetFocus %W
  127.         }
  128.     }
  129.     }
  130.     tk::MenuMotion %W %x %y %s
  131. }
  132.  
  133. bind Menu <Leave> {
  134.     tk::MenuLeave %W %X %Y %s
  135. }
  136. bind Menu <Motion> {
  137.     tk::MenuMotion %W %x %y %s
  138. }
  139. bind Menu <ButtonPress> {
  140.     tk::MenuButtonDown %W
  141. }
  142. bind Menu <ButtonRelease> {
  143.    tk::MenuInvoke %W 1
  144. }
  145. bind Menu <space> {
  146.     tk::MenuInvoke %W 0
  147. }
  148. bind Menu <Return> {
  149.     tk::MenuInvoke %W 0
  150. }
  151. bind Menu <Escape> {
  152.     tk::MenuEscape %W
  153. }
  154. bind Menu <Left> {
  155.     tk::MenuLeftArrow %W
  156. }
  157. bind Menu <Right> {
  158.     tk::MenuRightArrow %W
  159. }
  160. bind Menu <Up> {
  161.     tk::MenuUpArrow %W
  162. }
  163. bind Menu <Down> {
  164.     tk::MenuDownArrow %W
  165. }
  166. bind Menu <KeyPress> {
  167.     tk::TraverseWithinMenu %W %A
  168. }
  169.  
  170. # The following bindings apply to all windows, and are used to
  171. # implement keyboard menu traversal.
  172.  
  173. if {[tk windowingsystem] eq "x11"} {
  174.     bind all <Alt-KeyPress> {
  175.     tk::TraverseToMenu %W %A
  176.     }
  177.  
  178.     bind all <F10> {
  179.     tk::FirstMenu %W
  180.     }
  181. } else {
  182.     bind Menubutton <Alt-KeyPress> {
  183.     tk::TraverseToMenu %W %A
  184.     }
  185.  
  186.     bind Menubutton <F10> {
  187.     tk::FirstMenu %W
  188.     }
  189. }
  190.  
  191. # ::tk::MbEnter --
  192. # This procedure is invoked when the mouse enters a menubutton
  193. # widget.  It activates the widget unless it is disabled.  Note:
  194. # this procedure is only invoked when mouse button 1 is *not* down.
  195. # The procedure ::tk::MbB1Enter is invoked if the button is down.
  196. #
  197. # Arguments:
  198. # w -            The  name of the widget.
  199.  
  200. proc ::tk::MbEnter w {
  201.     variable ::tk::Priv
  202.  
  203.     if {$Priv(inMenubutton) ne ""} {
  204.     MbLeave $Priv(inMenubutton)
  205.     }
  206.     set Priv(inMenubutton) $w
  207.     if {[$w cget -state] ne "disabled" && [tk windowingsystem] ne "aqua"} {
  208.     $w configure -state active
  209.     }
  210. }
  211.  
  212. # ::tk::MbLeave --
  213. # This procedure is invoked when the mouse leaves a menubutton widget.
  214. # It de-activates the widget, if the widget still exists.
  215. #
  216. # Arguments:
  217. # w -            The  name of the widget.
  218.  
  219. proc ::tk::MbLeave w {
  220.     variable ::tk::Priv
  221.  
  222.     set Priv(inMenubutton) {}
  223.     if {![winfo exists $w]} {
  224.     return
  225.     }
  226.     if {[$w cget -state] eq "active" && [tk windowingsystem] ne "aqua"} {
  227.     $w configure -state normal
  228.     }
  229. }
  230.  
  231. # ::tk::MbPost --
  232. # Given a menubutton, this procedure does all the work of posting
  233. # its associated menu and unposting any other menu that is currently
  234. # posted.
  235. #
  236. # Arguments:
  237. # w -            The name of the menubutton widget whose menu
  238. #            is to be posted.
  239. # x, y -        Root coordinates of cursor, used for positioning
  240. #            option menus.  If not specified, then the center
  241. #            of the menubutton is used for an option menu.
  242.  
  243. proc ::tk::MbPost {w {x {}} {y {}}} {
  244.     global errorInfo
  245.     variable ::tk::Priv
  246.     global tcl_platform
  247.  
  248.     if {[$w cget -state] eq "disabled" || $w eq $Priv(postedMb)} {
  249.     return
  250.     }
  251.     set menu [$w cget -menu]
  252.     if {$menu eq ""} {
  253.     return
  254.     }
  255.     set tearoff [expr {[tk windowingsystem] eq "x11" \
  256.         || [$menu cget -type] eq "tearoff"}]
  257.     if {[string first $w $menu] != 0} {
  258.     error "can't post $menu:  it isn't a descendant of $w (this is a new requirement in Tk versions 3.0 and later)"
  259.     }
  260.     set cur $Priv(postedMb)
  261.     if {$cur ne ""} {
  262.     MenuUnpost {}
  263.     }
  264.     if {$::tk_strictMotif} {
  265.         set Priv(cursor) [$w cget -cursor]
  266.         $w configure -cursor arrow
  267.     }
  268.     if {[tk windowingsystem] ne "aqua"} {
  269.     set Priv(relief) [$w cget -relief]
  270.     $w configure -relief raised
  271.     } else {
  272.     $w configure -state active
  273.     }
  274.  
  275.     set Priv(postedMb) $w
  276.     set Priv(focus) [focus]
  277.     $menu activate none
  278.     GenerateMenuSelect $menu
  279.  
  280.     # If this looks like an option menubutton then post the menu so
  281.     # that the current entry is on top of the mouse.  Otherwise post
  282.     # the menu just below the menubutton, as for a pull-down.
  283.  
  284.     update idletasks
  285.     if {[catch {
  286.     switch [$w cget -direction] {
  287.             above {
  288.                 set x [winfo rootx $w]
  289.                 set y [expr {[winfo rooty $w] - [winfo reqheight $menu]}]
  290.         # if we go offscreen to the top, show as 'below'
  291.         if {$y < 0} {
  292.             set y [expr {[winfo rooty $w] + [winfo height $w]}]
  293.         }
  294.         PostOverPoint $menu $x $y
  295.             }
  296.             below {
  297.                 set x [winfo rootx $w]
  298.                 set y [expr {[winfo rooty $w] + [winfo height $w]}]
  299.         # if we go offscreen to the bottom, show as 'above'
  300.         set mh [winfo reqheight $menu]
  301.         if {($y + $mh) > [winfo screenheight $w]} {
  302.             set y [expr {[winfo rooty $w] - $mh}]
  303.         }
  304.         PostOverPoint $menu $x $y
  305.             }
  306.             left {
  307.                 set x [expr {[winfo rootx $w] - [winfo reqwidth $menu]}]
  308.                 set y [expr {(2 * [winfo rooty $w] + [winfo height $w]) / 2}]
  309.                 set entry [MenuFindName $menu [$w cget -text]]
  310.         if {[$w cget -indicatoron] && $entry ne ""} {
  311.             if {$entry == [$menu index last]} {
  312.                 incr y [expr {-([$menu yposition $entry] \
  313.                     + [winfo reqheight $menu])/2}]
  314.             } else {
  315.                 incr y [expr {-([$menu yposition $entry] \
  316.                     + [$menu yposition [expr {$entry+1}]])/2}]
  317.             }
  318.                 }
  319.         PostOverPoint $menu $x $y
  320.         if {$entry ne "" \
  321.             && [$menu entrycget $entry -state] ne "disabled"} {
  322.                     $menu activate $entry
  323.             GenerateMenuSelect $menu
  324.                 }
  325.             }
  326.             right {
  327.                 set x [expr {[winfo rootx $w] + [winfo width $w]}]
  328.                 set y [expr {(2 * [winfo rooty $w] + [winfo height $w]) / 2}]
  329.                 set entry [MenuFindName $menu [$w cget -text]]
  330.         if {[$w cget -indicatoron] && $entry ne ""} {
  331.             if {$entry == [$menu index last]} {
  332.                 incr y [expr {-([$menu yposition $entry] \
  333.                     + [winfo reqheight $menu])/2}]
  334.             } else {
  335.                 incr y [expr {-([$menu yposition $entry] \
  336.                     + [$menu yposition [expr {$entry+1}]])/2}]
  337.             }
  338.                 }
  339.         PostOverPoint $menu $x $y
  340.         if {$entry ne "" \
  341.             && [$menu entrycget $entry -state] ne "disabled"} {
  342.                     $menu activate $entry
  343.             GenerateMenuSelect $menu
  344.                 }
  345.             }
  346.             default {
  347.                 if {[$w cget -indicatoron]} {
  348.             if {$y eq ""} {
  349.             set x [expr {[winfo rootx $w] + [winfo width $w]/2}]
  350.             set y [expr {[winfo rooty $w] + [winfo height $w]/2}]
  351.                 }
  352.                 PostOverPoint $menu $x $y [MenuFindName $menu [$w cget -text]]
  353.         } else {
  354.             PostOverPoint $menu [winfo rootx $w] [expr {[winfo rooty $w]+[winfo height $w]}]
  355.                 }
  356.             }
  357.     }
  358.     } msg]} {
  359.     # Error posting menu (e.g. bogus -postcommand). Unpost it and
  360.     # reflect the error.
  361.     
  362.     set savedInfo $errorInfo
  363.     MenuUnpost {}
  364.     error $msg $savedInfo
  365.  
  366.     }
  367.  
  368.     set Priv(tearoff) $tearoff
  369.     if {$tearoff != 0} {
  370.         focus $menu
  371.     if {[winfo viewable $w]} {
  372.         SaveGrabInfo $w
  373.         grab -global $w
  374.     }
  375.     }
  376. }
  377.  
  378. # ::tk::MenuUnpost --
  379. # This procedure unposts a given menu, plus all of its ancestors up
  380. # to (and including) a menubutton, if any.  It also restores various
  381. # values to what they were before the menu was posted, and releases
  382. # a grab if there's a menubutton involved.  Special notes:
  383. # 1. It's important to unpost all menus before releasing the grab, so
  384. #    that any Enter-Leave events (e.g. from menu back to main
  385. #    application) have mode NotifyGrab.
  386. # 2. Be sure to enclose various groups of commands in "catch" so that
  387. #    the procedure will complete even if the menubutton or the menu
  388. #    or the grab window has been deleted.
  389. #
  390. # Arguments:
  391. # menu -        Name of a menu to unpost.  Ignored if there
  392. #            is a posted menubutton.
  393.  
  394. proc ::tk::MenuUnpost menu {
  395.     global tcl_platform
  396.     variable ::tk::Priv
  397.     set mb $Priv(postedMb)
  398.  
  399.     # Restore focus right away (otherwise X will take focus away when
  400.     # the menu is unmapped and under some window managers (e.g. olvwm)
  401.     # we'll lose the focus completely).
  402.  
  403.     catch {focus $Priv(focus)}
  404.     set Priv(focus) ""
  405.  
  406.     # Unpost menu(s) and restore some stuff that's dependent on
  407.     # what was posted.
  408.  
  409.     catch {
  410.     if {$mb ne ""} {
  411.         set menu [$mb cget -menu]
  412.         $menu unpost
  413.         set Priv(postedMb) {}
  414.         if {$::tk_strictMotif} {
  415.             $mb configure -cursor $Priv(cursor)
  416.         }
  417.         if {[tk windowingsystem] ne "aqua"} {
  418.         $mb configure -relief $Priv(relief)
  419.         } else {
  420.         $mb configure -state normal
  421.         }
  422.     } elseif {$Priv(popup) ne ""} {
  423.         $Priv(popup) unpost
  424.         set Priv(popup) {}
  425.     } elseif {[$menu cget -type] ne "menubar" \
  426.         && [$menu cget -type] ne "tearoff"} {
  427.         # We're in a cascaded sub-menu from a torn-off menu or popup.
  428.         # Unpost all the menus up to the toplevel one (but not
  429.         # including the top-level torn-off one) and deactivate the
  430.         # top-level torn off menu if there is one.
  431.  
  432.         while {1} {
  433.         set parent [winfo parent $menu]
  434.         if {[winfo class $parent] ne "Menu" \
  435.             || ![winfo ismapped $parent]} {
  436.             break
  437.         }
  438.         $parent activate none
  439.         $parent postcascade none
  440.         GenerateMenuSelect $parent
  441.         set type [$parent cget -type]
  442.         if {$type eq "menubar" || $type eq "tearoff"} {
  443.             break
  444.         }
  445.         set menu $parent
  446.         }
  447.         if {[$menu cget -type] ne "menubar"} {
  448.         $menu unpost
  449.         }
  450.     }
  451.     }
  452.  
  453.     if {($Priv(tearoff) != 0) || $Priv(menuBar) ne ""} {
  454.         # Release grab, if any, and restore the previous grab, if there
  455.         # was one.
  456.     if {$menu ne ""} {
  457.         set grab [grab current $menu]
  458.         if {$grab ne ""} {
  459.         grab release $grab
  460.         }
  461.     }
  462.     RestoreOldGrab
  463.     if {$Priv(menuBar) ne ""} {
  464.         if {$::tk_strictMotif} {
  465.         $Priv(menuBar) configure -cursor $Priv(cursor)
  466.         }
  467.         set Priv(menuBar) {}
  468.     }
  469.     if {[tk windowingsystem] ne "x11"} {
  470.         set Priv(tearoff) 0
  471.     }
  472.     }
  473. }
  474.  
  475. # ::tk::MbMotion --
  476. # This procedure handles mouse motion events inside menubuttons, and
  477. # also outside menubuttons when a menubutton has a grab (e.g. when a
  478. # menu selection operation is in progress).
  479. #
  480. # Arguments:
  481. # w -            The name of the menubutton widget.
  482. # upDown -         "down" means button 1 is pressed, "up" means
  483. #            it isn't.
  484. # rootx, rooty -    Coordinates of mouse, in (virtual?) root window.
  485.  
  486. proc ::tk::MbMotion {w upDown rootx rooty} {
  487.     variable ::tk::Priv
  488.  
  489.     if {$Priv(inMenubutton) eq $w} {
  490.     return
  491.     }
  492.     set new [winfo containing $rootx $rooty]
  493.     if {$new ne $Priv(inMenubutton) \
  494.         && ($new eq "" || [winfo toplevel $new] eq [winfo toplevel $w])} {
  495.     if {$Priv(inMenubutton) ne ""} {
  496.         MbLeave $Priv(inMenubutton)
  497.     }
  498.     if {$new ne "" \
  499.         && [winfo class $new] eq "Menubutton" \
  500.         && ([$new cget -indicatoron] == 0) \
  501.         && ([$w cget -indicatoron] == 0)} {
  502.         if {$upDown eq "down"} {
  503.         MbPost $new $rootx $rooty
  504.         } else {
  505.         MbEnter $new
  506.         }
  507.     }
  508.     }
  509. }
  510.  
  511. # ::tk::MbButtonUp --
  512. # This procedure is invoked to handle button 1 releases for menubuttons.
  513. # If the release happens inside the menubutton then leave its menu
  514. # posted with element 0 activated.  Otherwise, unpost the menu.
  515. #
  516. # Arguments:
  517. # w -            The name of the menubutton widget.
  518.  
  519. proc ::tk::MbButtonUp w {
  520.     variable ::tk::Priv
  521.     global tcl_platform
  522.  
  523.     set menu [$w cget -menu]
  524.     set tearoff [expr {[tk windowingsystem] eq "x11" || \
  525.         ($menu ne "" && [$menu cget -type] eq "tearoff")}]
  526.     if {($tearoff != 0) && $Priv(postedMb) eq $w \
  527.         && $Priv(inMenubutton) eq $w} {
  528.     MenuFirstEntry [$Priv(postedMb) cget -menu]
  529.     } else {
  530.     MenuUnpost {}
  531.     }
  532. }
  533.  
  534. # ::tk::MenuMotion --
  535. # This procedure is called to handle mouse motion events for menus.
  536. # It does two things.  First, it resets the active element in the
  537. # menu, if the mouse is over the menu.  Second, if a mouse button
  538. # is down, it posts and unposts cascade entries to match the mouse
  539. # position.
  540. #
  541. # Arguments:
  542. # menu -        The menu window.
  543. # x -            The x position of the mouse.
  544. # y -            The y position of the mouse.
  545. # state -        Modifier state (tells whether buttons are down).
  546.  
  547. proc ::tk::MenuMotion {menu x y state} {
  548.     variable ::tk::Priv
  549.     if {$menu eq $Priv(window)} {
  550.     if {[$menu cget -type] eq "menubar"} {
  551.         if {[info exists Priv(focus)] && $menu ne $Priv(focus)} {
  552.         $menu activate @$x,$y
  553.         GenerateMenuSelect $menu
  554.         }
  555.     } else {
  556.         $menu activate @$x,$y
  557.         GenerateMenuSelect $menu
  558.     }
  559.     }
  560.     if {($state & 0x1f00) != 0} {
  561.     $menu postcascade active
  562.     }
  563. }
  564.  
  565. # ::tk::MenuButtonDown --
  566. # Handles button presses in menus.  There are a couple of tricky things
  567. # here:
  568. # 1. Change the posted cascade entry (if any) to match the mouse position.
  569. # 2. If there is a posted menubutton, must grab to the menubutton;  this
  570. #    overrrides the implicit grab on button press, so that the menu
  571. #    button can track mouse motions over other menubuttons and change
  572. #    the posted menu.
  573. # 3. If there's no posted menubutton (e.g. because we're a torn-off menu
  574. #    or one of its descendants) must grab to the top-level menu so that
  575. #    we can track mouse motions across the entire menu hierarchy.
  576. #
  577. # Arguments:
  578. # menu -        The menu window.
  579.  
  580. proc ::tk::MenuButtonDown menu {
  581.     variable ::tk::Priv
  582.     global tcl_platform
  583.  
  584.     if {![winfo viewable $menu]} {
  585.         return
  586.     }
  587.     $menu postcascade active
  588.     if {$Priv(postedMb) ne "" && [winfo viewable $Priv(postedMb)]} {
  589.     grab -global $Priv(postedMb)
  590.     } else {
  591.     while {[$menu cget -type] eq "normal" \
  592.         && [winfo class [winfo parent $menu]] eq "Menu" \
  593.         && [winfo ismapped [winfo parent $menu]]} {
  594.         set menu [winfo parent $menu]
  595.     }
  596.  
  597.     if {$Priv(menuBar) eq {}} {
  598.         set Priv(menuBar) $menu
  599.         if {$::tk_strictMotif} {
  600.         set Priv(cursor) [$menu cget -cursor]
  601.         $menu configure -cursor arrow
  602.         }
  603.         }
  604.  
  605.     # Don't update grab information if the grab window isn't changing.
  606.     # Otherwise, we'll get an error when we unpost the menus and
  607.     # restore the grab, since the old grab window will not be viewable
  608.     # anymore.
  609.  
  610.     if {$menu ne [grab current $menu]} {
  611.         SaveGrabInfo $menu
  612.     }
  613.  
  614.     # Must re-grab even if the grab window hasn't changed, in order
  615.     # to release the implicit grab from the button press.
  616.  
  617.     if {[tk windowingsystem] eq "x11"} {
  618.         grab -global $menu
  619.     }
  620.     }
  621. }
  622.  
  623. # ::tk::MenuLeave --
  624. # This procedure is invoked to handle Leave events for a menu.  It
  625. # deactivates everything unless the active element is a cascade element
  626. # and the mouse is now over the submenu.
  627. #
  628. # Arguments:
  629. # menu -        The menu window.
  630. # rootx, rooty -    Root coordinates of mouse.
  631. # state -        Modifier state.
  632.  
  633. proc ::tk::MenuLeave {menu rootx rooty state} {
  634.     variable ::tk::Priv
  635.     set Priv(window) {}
  636.     if {[$menu index active] eq "none"} {
  637.     return
  638.     }
  639.     if {[$menu type active] eq "cascade" \
  640.         && [winfo containing $rootx $rooty] eq \
  641.         [$menu entrycget active -menu]} {
  642.     return
  643.     }
  644.     $menu activate none
  645.     GenerateMenuSelect $menu
  646. }
  647.  
  648. # ::tk::MenuInvoke --
  649. # This procedure is invoked when button 1 is released over a menu.
  650. # It invokes the appropriate menu action and unposts the menu if
  651. # it came from a menubutton.
  652. #
  653. # Arguments:
  654. # w -            Name of the menu widget.
  655. # buttonRelease -    1 means this procedure is called because of
  656. #            a button release;  0 means because of keystroke.
  657.  
  658. proc ::tk::MenuInvoke {w buttonRelease} {
  659.     variable ::tk::Priv
  660.  
  661.     if {$buttonRelease && $Priv(window) eq ""} {
  662.     # Mouse was pressed over a menu without a menu button, then
  663.     # dragged off the menu (possibly with a cascade posted) and
  664.     # released.  Unpost everything and quit.
  665.  
  666.     $w postcascade none
  667.     $w activate none
  668.     event generate $w <<MenuSelect>>
  669.     MenuUnpost $w
  670.     return
  671.     }
  672.     if {[$w type active] eq "cascade"} {
  673.     $w postcascade active
  674.     set menu [$w entrycget active -menu]
  675.     MenuFirstEntry $menu
  676.     } elseif {[$w type active] eq "tearoff"} {
  677.     ::tk::TearOffMenu $w
  678.     MenuUnpost $w
  679.     } elseif {[$w cget -type] eq "menubar"} {
  680.     $w postcascade none
  681.     set active [$w index active]
  682.     set isCascade [string equal [$w type $active] "cascade"]
  683.  
  684.     # Only de-activate the active item if it's a cascade; this prevents
  685.     # the annoying "activation flicker" you otherwise get with 
  686.     # checkbuttons/commands/etc. on menubars
  687.  
  688.     if { $isCascade } {
  689.         $w activate none
  690.         event generate $w <<MenuSelect>>
  691.     }
  692.  
  693.     MenuUnpost $w
  694.  
  695.     # If the active item is not a cascade, invoke it.  This enables
  696.     # the use of checkbuttons/commands/etc. on menubars (which is legal,
  697.     # but not recommended)
  698.  
  699.     if { !$isCascade } {
  700.         uplevel #0 [list $w invoke $active]
  701.     }
  702.     } else {
  703.     set active [$w index active]
  704.     if {$Priv(popup) eq "" || $active ne "none"} {
  705.         MenuUnpost $w
  706.     }
  707.     uplevel #0 [list $w invoke active]
  708.     }
  709. }
  710.  
  711. # ::tk::MenuEscape --
  712. # This procedure is invoked for the Cancel (or Escape) key.  It unposts
  713. # the given menu and, if it is the top-level menu for a menu button,
  714. # unposts the menu button as well.
  715. #
  716. # Arguments:
  717. # menu -        Name of the menu window.
  718.  
  719. proc ::tk::MenuEscape menu {
  720.     set parent [winfo parent $menu]
  721.     if {[winfo class $parent] ne "Menu"} {
  722.     MenuUnpost $menu
  723.     } elseif {[$parent cget -type] eq "menubar"} {
  724.     MenuUnpost $menu
  725.     RestoreOldGrab
  726.     } else {
  727.     MenuNextMenu $menu left
  728.     }
  729. }
  730.  
  731. # The following routines handle arrow keys. Arrow keys behave
  732. # differently depending on whether the menu is a menu bar or not.
  733.  
  734. proc ::tk::MenuUpArrow {menu} {
  735.     if {[$menu cget -type] eq "menubar"} {
  736.     MenuNextMenu $menu left
  737.     } else {
  738.     MenuNextEntry $menu -1
  739.     }
  740. }
  741.  
  742. proc ::tk::MenuDownArrow {menu} {
  743.     if {[$menu cget -type] eq "menubar"} {
  744.     MenuNextMenu $menu right
  745.     } else {
  746.     MenuNextEntry $menu 1
  747.     }
  748. }
  749.  
  750. proc ::tk::MenuLeftArrow {menu} {
  751.     if {[$menu cget -type] eq "menubar"} {
  752.     MenuNextEntry $menu -1
  753.     } else {
  754.     MenuNextMenu $menu left
  755.     }
  756. }
  757.  
  758. proc ::tk::MenuRightArrow {menu} {
  759.     if {[$menu cget -type] eq "menubar"} {
  760.     MenuNextEntry $menu 1
  761.     } else {
  762.     MenuNextMenu $menu right
  763.     }
  764. }
  765.  
  766. # ::tk::MenuNextMenu --
  767. # This procedure is invoked to handle "left" and "right" traversal
  768. # motions in menus.  It traverses to the next menu in a menu bar,
  769. # or into or out of a cascaded menu.
  770. #
  771. # Arguments:
  772. # menu -        The menu that received the keyboard
  773. #            event.
  774. # direction -        Direction in which to move: "left" or "right"
  775.  
  776. proc ::tk::MenuNextMenu {menu direction} {
  777.     variable ::tk::Priv
  778.  
  779.     # First handle traversals into and out of cascaded menus.
  780.  
  781.     if {$direction eq "right"} {
  782.     set count 1
  783.     set parent [winfo parent $menu]
  784.     set class [winfo class $parent]
  785.     if {[$menu type active] eq "cascade"} {
  786.         $menu postcascade active
  787.         set m2 [$menu entrycget active -menu]
  788.         if {$m2 ne ""} {
  789.         MenuFirstEntry $m2
  790.         }
  791.         return
  792.     } else {
  793.         set parent [winfo parent $menu]
  794.         while {$parent ne "."} {
  795.         if {[winfo class $parent] eq "Menu" \
  796.             && [$parent cget -type] eq "menubar"} {
  797.             tk_menuSetFocus $parent
  798.             MenuNextEntry $parent 1
  799.             return
  800.         }
  801.         set parent [winfo parent $parent]
  802.         }
  803.     }
  804.     } else {
  805.     set count -1
  806.     set m2 [winfo parent $menu]
  807.     if {[winfo class $m2] eq "Menu"} {
  808.         $menu activate none
  809.         GenerateMenuSelect $menu
  810.         tk_menuSetFocus $m2
  811.  
  812.         $m2 postcascade none
  813.  
  814.         if {[$m2 cget -type] ne "menubar"} {
  815.         return
  816.         }
  817.     }
  818.     }
  819.  
  820.     # Can't traverse into or out of a cascaded menu. Go to the next
  821.     # or previous menubutton, if that makes sense.
  822.  
  823.     set m2 [winfo parent $menu]
  824.     if {[winfo class $m2] eq "Menu" && [$m2 cget -type] eq "menubar"} {
  825.     tk_menuSetFocus $m2
  826.     MenuNextEntry $m2 -1
  827.     return
  828.     }
  829.  
  830.     set w $Priv(postedMb)
  831.     if {$w eq ""} {
  832.     return
  833.     }
  834.     set buttons [winfo children [winfo parent $w]]
  835.     set length [llength $buttons]
  836.     set i [expr {[lsearch -exact $buttons $w] + $count}]
  837.     while {1} {
  838.     while {$i < 0} {
  839.         incr i $length
  840.     }
  841.     while {$i >= $length} {
  842.         incr i -$length
  843.     }
  844.     set mb [lindex $buttons $i]
  845.     if {[winfo class $mb] eq "Menubutton" \
  846.         && [$mb cget -state] ne "disabled" \
  847.         && [$mb cget -menu] ne "" \
  848.         && [[$mb cget -menu] index last] ne "none"} {
  849.         break
  850.     }
  851.     if {$mb eq $w} {
  852.         return
  853.     }
  854.     incr i $count
  855.     }
  856.     MbPost $mb
  857.     MenuFirstEntry [$mb cget -menu]
  858. }
  859.  
  860. # ::tk::MenuNextEntry --
  861. # Activate the next higher or lower entry in the posted menu,
  862. # wrapping around at the ends.  Disabled entries are skipped.
  863. #
  864. # Arguments:
  865. # menu -            Menu window that received the keystroke.
  866. # count -            1 means go to the next lower entry,
  867. #                -1 means go to the next higher entry.
  868.  
  869. proc ::tk::MenuNextEntry {menu count} {
  870.     if {[$menu index last] eq "none"} {
  871.     return
  872.     }
  873.     set length [expr {[$menu index last]+1}]
  874.     set quitAfter $length
  875.     set active [$menu index active]
  876.     if {$active eq "none"} {
  877.     set i 0
  878.     } else {
  879.     set i [expr {$active + $count}]
  880.     }
  881.     while {1} {
  882.     if {$quitAfter <= 0} {
  883.         # We've tried every entry in the menu.  Either there are
  884.         # none, or they're all disabled.  Just give up.
  885.  
  886.         return
  887.     }
  888.     while {$i < 0} {
  889.         incr i $length
  890.     }
  891.     while {$i >= $length} {
  892.         incr i -$length
  893.     }
  894.     if {[catch {$menu entrycget $i -state} state] == 0} {
  895.         if {$state ne "disabled" && \
  896.             ($i!=0 || [$menu cget -type] ne "tearoff" \
  897.             || [$menu type 0] ne "tearoff")} {
  898.         break
  899.         }
  900.     }
  901.     if {$i == $active} {
  902.         return
  903.     }
  904.     incr i $count
  905.     incr quitAfter -1
  906.     }
  907.     $menu activate $i
  908.     GenerateMenuSelect $menu
  909.  
  910.     if {[$menu type $i] eq "cascade" && [$menu cget -type] eq "menubar"} {
  911.     set cascade [$menu entrycget $i -menu]
  912.     if {$cascade ne ""} {
  913.         # Here we auto-post a cascade.  This is necessary when
  914.         # we traverse left/right in the menubar, but undesirable when
  915.         # we traverse up/down in a menu.
  916.         $menu postcascade $i
  917.         MenuFirstEntry $cascade
  918.     }
  919.     }
  920. }
  921.  
  922. # ::tk::MenuFind --
  923. # This procedure searches the entire window hierarchy under w for
  924. # a menubutton that isn't disabled and whose underlined character
  925. # is "char" or an entry in a menubar that isn't disabled and whose
  926. # underlined character is "char".
  927. # It returns the name of that window, if found, or an
  928. # empty string if no matching window was found.  If "char" is an
  929. # empty string then the procedure returns the name of the first
  930. # menubutton found that isn't disabled.
  931. #
  932. # Arguments:
  933. # w -                Name of window where key was typed.
  934. # char -            Underlined character to search for;
  935. #                may be either upper or lower case, and
  936. #                will match either upper or lower case.
  937.  
  938. proc ::tk::MenuFind {w char} {
  939.     set char [string tolower $char]
  940.     set windowlist [winfo child $w]
  941.  
  942.     foreach child $windowlist {
  943.     # Don't descend into other toplevels.
  944.         if {[winfo toplevel $w] ne [winfo toplevel $child]} {
  945.         continue
  946.     }
  947.     if {[winfo class $child] eq "Menu" && \
  948.         [$child cget -type] eq "menubar"} {
  949.         if {$char eq ""} {
  950.         return $child
  951.         }
  952.         set last [$child index last]
  953.         for {set i [$child cget -tearoff]} {$i <= $last} {incr i} {
  954.         if {[$child type $i] eq "separator"} {
  955.             continue
  956.         }
  957.         set char2 [string index [$child entrycget $i -label] \
  958.             [$child entrycget $i -underline]]
  959.         if {$char eq [string tolower $char2] || $char eq ""} {
  960.             if {[$child entrycget $i -state] ne "disabled"} {
  961.             return $child
  962.             }
  963.         }
  964.         }
  965.     }
  966.     }
  967.  
  968.     foreach child $windowlist {
  969.     # Don't descend into other toplevels.
  970.         if {[winfo toplevel $w] ne [winfo toplevel $child]} {
  971.         continue
  972.     }
  973.     switch -- [winfo class $child] {
  974.         Menubutton {
  975.         set char2 [string index [$child cget -text] \
  976.             [$child cget -underline]]
  977.         if {$char eq [string tolower $char2] || $char eq ""} {
  978.             if {[$child cget -state] ne "disabled"} {
  979.             return $child
  980.             }
  981.         }
  982.         }
  983.  
  984.         default {
  985.         set match [MenuFind $child $char]
  986.         if {$match ne ""} {
  987.             return $match
  988.         }
  989.         }
  990.     }
  991.     }
  992.     return {}
  993. }
  994.  
  995. # ::tk::TraverseToMenu --
  996. # This procedure implements keyboard traversal of menus.  Given an
  997. # ASCII character "char", it looks for a menubutton with that character
  998. # underlined.  If one is found, it posts the menubutton's menu
  999. #
  1000. # Arguments:
  1001. # w -                Window in which the key was typed (selects
  1002. #                a toplevel window).
  1003. # char -            Character that selects a menu.  The case
  1004. #                is ignored.  If an empty string, nothing
  1005. #                happens.
  1006.  
  1007. proc ::tk::TraverseToMenu {w char} {
  1008.     variable ::tk::Priv
  1009.     if {$char eq ""} {
  1010.     return
  1011.     }
  1012.     while {[winfo class $w] eq "Menu"} {
  1013.     if {[$w cget -type] ne "menubar" && $Priv(postedMb) eq ""} {
  1014.         return
  1015.     }
  1016.     if {[$w cget -type] eq "menubar"} {
  1017.         break
  1018.     }
  1019.     set w [winfo parent $w]
  1020.     }
  1021.     set w [MenuFind [winfo toplevel $w] $char]
  1022.     if {$w ne ""} {
  1023.     if {[winfo class $w] eq "Menu"} {
  1024.         tk_menuSetFocus $w
  1025.         set Priv(window) $w
  1026.         SaveGrabInfo $w
  1027.         grab -global $w
  1028.         TraverseWithinMenu $w $char
  1029.     } else {
  1030.         MbPost $w
  1031.         MenuFirstEntry [$w cget -menu]
  1032.     }
  1033.     }
  1034. }
  1035.  
  1036. # ::tk::FirstMenu --
  1037. # This procedure traverses to the first menubutton in the toplevel
  1038. # for a given window, and posts that menubutton's menu.
  1039. #
  1040. # Arguments:
  1041. # w -                Name of a window.  Selects which toplevel
  1042. #                to search for menubuttons.
  1043.  
  1044. proc ::tk::FirstMenu w {
  1045.     variable ::tk::Priv
  1046.     set w [MenuFind [winfo toplevel $w] ""]
  1047.     if {$w ne ""} {
  1048.     if {[winfo class $w] eq "Menu"} {
  1049.         tk_menuSetFocus $w
  1050.         set Priv(window) $w
  1051.         SaveGrabInfo $w
  1052.         grab -global $w
  1053.         MenuFirstEntry $w
  1054.     } else {
  1055.         MbPost $w
  1056.         MenuFirstEntry [$w cget -menu]
  1057.     }
  1058.     }
  1059. }
  1060.  
  1061. # ::tk::TraverseWithinMenu
  1062. # This procedure implements keyboard traversal within a menu.  It
  1063. # searches for an entry in the menu that has "char" underlined.  If
  1064. # such an entry is found, it is invoked and the menu is unposted.
  1065. #
  1066. # Arguments:
  1067. # w -                The name of the menu widget.
  1068. # char -            The character to look for;  case is
  1069. #                ignored.  If the string is empty then
  1070. #                nothing happens.
  1071.  
  1072. proc ::tk::TraverseWithinMenu {w char} {
  1073.     if {$char eq ""} {
  1074.     return
  1075.     }
  1076.     set char [string tolower $char]
  1077.     set last [$w index last]
  1078.     if {$last eq "none"} {
  1079.     return
  1080.     }
  1081.     for {set i 0} {$i <= $last} {incr i} {
  1082.     if {[catch {set char2 [string index \
  1083.         [$w entrycget $i -label] [$w entrycget $i -underline]]}]} {
  1084.         continue
  1085.     }
  1086.     if {$char eq [string tolower $char2]} {
  1087.         if {[$w type $i] eq "cascade"} {
  1088.         $w activate $i
  1089.         $w postcascade active
  1090.         event generate $w <<MenuSelect>>
  1091.         set m2 [$w entrycget $i -menu]
  1092.         if {$m2 ne ""} {
  1093.             MenuFirstEntry $m2
  1094.         }
  1095.         } else {
  1096.         MenuUnpost $w
  1097.         uplevel #0 [list $w invoke $i]
  1098.         }
  1099.         return
  1100.     }
  1101.     }
  1102. }
  1103.  
  1104. # ::tk::MenuFirstEntry --
  1105. # Given a menu, this procedure finds the first entry that isn't
  1106. # disabled or a tear-off or separator, and activates that entry.
  1107. # However, if there is already an active entry in the menu (e.g.,
  1108. # because of a previous call to tk::PostOverPoint) then the active
  1109. # entry isn't changed.  This procedure also sets the input focus
  1110. # to the menu.
  1111. #
  1112. # Arguments:
  1113. # menu -        Name of the menu window (possibly empty).
  1114.  
  1115. proc ::tk::MenuFirstEntry menu {
  1116.     if {$menu eq ""} {
  1117.     return
  1118.     }
  1119.     tk_menuSetFocus $menu
  1120.     if {[$menu index active] ne "none"} {
  1121.     return
  1122.     }
  1123.     set last [$menu index last]
  1124.     if {$last eq "none"} {
  1125.     return
  1126.     }
  1127.     for {set i 0} {$i <= $last} {incr i} {
  1128.     if {([catch {set state [$menu entrycget $i -state]}] == 0) \
  1129.         && $state ne "disabled" && [$menu type $i] ne "tearoff"} {
  1130.         $menu activate $i
  1131.         GenerateMenuSelect $menu
  1132.         # Only post the cascade if the current menu is a menubar;
  1133.         # otherwise, if the first entry of the cascade is a cascade,
  1134.         # we can get an annoying cascading effect resulting in a bunch of
  1135.         # menus getting posted (bug 676)
  1136.         if {[$menu type $i] eq "cascade" \
  1137.             && [$menu cget -type] eq "menubar"} {
  1138.         set cascade [$menu entrycget $i -menu]
  1139.         if {$cascade ne ""} {
  1140.             $menu postcascade $i
  1141.             MenuFirstEntry $cascade
  1142.         }
  1143.         }
  1144.         return
  1145.     }
  1146.     }
  1147. }
  1148.  
  1149. # ::tk::MenuFindName --
  1150. # Given a menu and a text string, return the index of the menu entry
  1151. # that displays the string as its label.  If there is no such entry,
  1152. # return an empty string.  This procedure is tricky because some names
  1153. # like "active" have a special meaning in menu commands, so we can't
  1154. # always use the "index" widget command.
  1155. #
  1156. # Arguments:
  1157. # menu -        Name of the menu widget.
  1158. # s -            String to look for.
  1159.  
  1160. proc ::tk::MenuFindName {menu s} {
  1161.     set i ""
  1162.     if {![regexp {^active$|^last$|^none$|^[0-9]|^@} $s]} {
  1163.     catch {set i [$menu index $s]}
  1164.     return $i
  1165.     }
  1166.     set last [$menu index last]
  1167.     if {$last eq "none"} {
  1168.     return
  1169.     }
  1170.     for {set i 0} {$i <= $last} {incr i} {
  1171.     if {![catch {$menu entrycget $i -label} label]} {
  1172.         if {$label eq $s} {
  1173.         return $i
  1174.         }
  1175.     }
  1176.     }
  1177.     return ""
  1178. }
  1179.  
  1180. # ::tk::PostOverPoint --
  1181. # This procedure posts a given menu such that a given entry in the
  1182. # menu is centered over a given point in the root window.  It also
  1183. # activates the given entry.
  1184. #
  1185. # Arguments:
  1186. # menu -        Menu to post.
  1187. # x, y -        Root coordinates of point.
  1188. # entry -        Index of entry within menu to center over (x,y).
  1189. #            If omitted or specified as {}, then the menu's
  1190. #            upper-left corner goes at (x,y).
  1191.  
  1192. proc ::tk::PostOverPoint {menu x y {entry {}}}  {
  1193.     global tcl_platform
  1194.     
  1195.     if {$entry ne ""} {
  1196.     if {$entry == [$menu index last]} {
  1197.         incr y [expr {-([$menu yposition $entry] \
  1198.             + [winfo reqheight $menu])/2}]
  1199.     } else {
  1200.         incr y [expr {-([$menu yposition $entry] \
  1201.             + [$menu yposition [expr {$entry+1}]])/2}]
  1202.     }
  1203.     incr x [expr {-[winfo reqwidth $menu]/2}]
  1204.     }
  1205.     if {$tcl_platform(platform) == "windows"} {
  1206.     # We need to fix some problems with menu posting on Windows,
  1207.     # where, if the menu would overlap top or bottom of screen,
  1208.     # Windows puts it in the wrong place for us.  We must also
  1209.     # subtract an extra amount for half the height of the current
  1210.     # entry.  To be safe we subtract an extra 10.
  1211.     set yoffset [expr {[winfo screenheight $menu] \
  1212.         - $y - [winfo reqheight $menu] - 10}]
  1213.     if {$yoffset < 0} {
  1214.         # The bottom of the menu is offscreen, so adjust upwards
  1215.         incr y $yoffset
  1216.         if {$y < 0} { set y 0 }
  1217.     }
  1218.     # If we're off the top of the screen (either because we were
  1219.     # originally or because we just adjusted too far upwards),
  1220.     # then make the menu popup on the top edge.
  1221.     if {$y < 0} {
  1222.         set y 0
  1223.     }
  1224.     }
  1225.     $menu post $x $y
  1226.     if {$entry ne "" && [$menu entrycget $entry -state] ne "disabled"} {
  1227.     $menu activate $entry
  1228.     GenerateMenuSelect $menu
  1229.     }
  1230. }
  1231.  
  1232. # ::tk::SaveGrabInfo --
  1233. # Sets the variables tk::Priv(oldGrab) and tk::Priv(grabStatus) to record
  1234. # the state of any existing grab on the w's display.
  1235. #
  1236. # Arguments:
  1237. # w -            Name of a window;  used to select the display
  1238. #            whose grab information is to be recorded.
  1239.  
  1240. proc tk::SaveGrabInfo w {
  1241.     variable ::tk::Priv
  1242.     set Priv(oldGrab) [grab current $w]
  1243.     if {$Priv(oldGrab) ne ""} {
  1244.     set Priv(grabStatus) [grab status $Priv(oldGrab)]
  1245.     }
  1246. }
  1247.  
  1248. # ::tk::RestoreOldGrab --
  1249. # Restores the grab to what it was before TkSaveGrabInfo was called.
  1250. #
  1251.  
  1252. proc ::tk::RestoreOldGrab {} {
  1253.     variable ::tk::Priv
  1254.  
  1255.     if {$Priv(oldGrab) ne ""} {
  1256.         # Be careful restoring the old grab, since it's window may not
  1257.     # be visible anymore.
  1258.  
  1259.     catch {
  1260.         if {$Priv(grabStatus) eq "global"} {
  1261.         grab set -global $Priv(oldGrab)
  1262.         } else {
  1263.         grab set $Priv(oldGrab)
  1264.         }
  1265.     }
  1266.     set Priv(oldGrab) ""
  1267.     }
  1268. }
  1269.  
  1270. proc ::tk_menuSetFocus {menu} {
  1271.     variable ::tk::Priv
  1272.     if {![info exists Priv(focus)] || $Priv(focus) eq ""} {
  1273.     set Priv(focus) [focus]
  1274.     }
  1275.     focus $menu
  1276. }
  1277.     
  1278. proc ::tk::GenerateMenuSelect {menu} {
  1279.     variable ::tk::Priv
  1280.  
  1281.     if {$Priv(activeMenu) eq $menu \
  1282.         && $Priv(activeItem) eq [$menu index active]} {
  1283.     return
  1284.     }
  1285.  
  1286.     set Priv(activeMenu) $menu
  1287.     set Priv(activeItem) [$menu index active]
  1288.     event generate $menu <<MenuSelect>>
  1289. }
  1290.  
  1291. # ::tk_popup --
  1292. # This procedure pops up a menu and sets things up for traversing
  1293. # the menu and its submenus.
  1294. #
  1295. # Arguments:
  1296. # menu -        Name of the menu to be popped up.
  1297. # x, y -        Root coordinates at which to pop up the
  1298. #            menu.
  1299. # entry -        Index of a menu entry to center over (x,y).
  1300. #            If omitted or specified as {}, then menu's
  1301. #            upper-left corner goes at (x,y).
  1302.  
  1303. proc ::tk_popup {menu x y {entry {}}} {
  1304.     variable ::tk::Priv
  1305.     global tcl_platform
  1306.     if {$Priv(popup) ne "" || $Priv(postedMb) ne ""} {
  1307.     tk::MenuUnpost {}
  1308.     }
  1309.     tk::PostOverPoint $menu $x $y $entry
  1310.     if {[tk windowingsystem] eq "x11" && [winfo viewable $menu]} {
  1311.         tk::SaveGrabInfo $menu
  1312.     grab -global $menu
  1313.     set Priv(popup) $menu
  1314.     tk_menuSetFocus $menu
  1315.     }
  1316. }
  1317.